# Copyright 2008-2009 Michael De Soto via Quarg Studio. This program is
# distributed under the terms of the GNU General Public License, version 3.
#
# $Id: XML.pm 6 2009-04-24 04:57:31Z desoto@cpan.org $

package Net::DNS::XML;

use strict;
use warnings;

use feature qw / switch /;
use base qw/ XML::Simple /;

use Net::DNS::Packet;
$Net::DNS::XML::VERSION = '0.02';


sub XMLin {
    my $self = shift; 
    my $object = shift; # Valid Net::DNS::Packet object.
    my (%options) = @_; # Options passed directly to XML::Simple.

    return $self->SUPER::XMLin($object, %options);
}

sub XMLout {
    my $self = shift;
    my $object = shift; # Valid Net::DNS::Packet object.
    my (%options) = @_; # Options passed directly to XML::Simple.

    # Send Net::DNS::Packet object off to be parsed.
    my %p = __parse_object($object);
    
    # Send parsed Net::DNS::Packet object to XML::Simple.
    return $self->SUPER::XMLout(\%p, %options);
}

sub __parse_object {
    my $object = shift; # Valid Net::DNS::Packet object.
    my %p; # p is for packet.

    # Net::DNS::Packet objects have 6 sections we care about:
    # 1. Envelope (contains ->answerfrom and ->answersize).
    # 2. Header (single Net::DNS::Header object).
    # 3. Question (list of Net::DNS::Question objects).
    # 4. Answser (list of Net::DNS::RR objects).
    # 5. Authority (list of Net::DNS::RR objects).
    # 6. Additional (list of Net::DNS::RR objects).
    
    
    # 1) Start by writing envelope to the hash.
    $p{packet}->{answerfrom} = $object->answerfrom;
    $p{packet}->{answersize} = $object->answersize;
    
    # 2) Next pull header object into hash.
    $p{packet}->{header} = $object->header;

    # 3) Next iterate over array of question objects.
    my @questions = ();
    foreach ($object->question) {
        my @q = ({ qname => $_->qname, qtype => $_->qtype, qclass => $_->qclass });
        push(@questions, @q);
    }
    $p{packet}->{questions}->{question} = \@questions;

    # 4) Next iterate over array of answer objects. We call __parse_rr here
    # because all Net::DNS::RR objects share essentially the same structure.
    my @answers = ();
    foreach ($object->answer) {
        my @a = __parse_rr($_);
        push(@answers, @a);
    }
    $p{packet}->{answers}->{answer} = \@answers;
    
    # 5) Next iterate over array of authority objects. We call __parse_rr here
    # because all Net::DNS::RR objects share essentially the same structure.    
    my @authorities = ();
    foreach ($object->authority) {
        my @a = __parse_rr($_);
        push(@authorities, @a);
    }
    $p{packet}->{authorities}->{authority} = \@authorities;

    # 6) Next iterate over array of additional objects. We call __parse_rr here
    # because all Net::DNS::RR objects share essentially the same structure.
    my @additionals = ();
    foreach ($object->additional) {
        my @a = __parse_rr($_);
        push(@additionals, @a);
    }
    $p{packet}->{additionals}->{additional} = \@additionals;
    
    # Hash is now complete.   
    return %p;
}


sub __parse_rr {
    my $object = shift;
    
    # All Net::DNS::RR objects share a common structure. We write the common
    # elements here.
    my @a = ({
        name => $object->name, 
        type => $object->type, 
        class => $object->class, 
        ttl => $object->ttl, 
        rdlength => $object->rdlength
    });
    
    # However, there are differences. Each Net::DNS::RR object has a subclass
    # which represents the actual record. We write these elements here.
    given ($object->type) {
        when ('A' || 'AAAA') {
            $a[0]{address} = $object->address;
        }
        when ('APL') {
#              foreach my $ap ($apl->aplist()){
#                    print $ap->negation()?"!":"";		
#                    print $ap->addressfamily().":";		
#                    print $ap->address();		
#                    print $ap->prefix(). " ";
#                }
        }
        when ('AFSDB') {
            $a[0]{subtype} = $object->subtype;
            $a[0]{hostname} = $object->hostname;
        }
        when ('CERT') {
            $a[0]{format} = $object->format;
            $a[0]{tag} = $object->tag;
            $a[0]{algorithm} = $object->algorithm;
#            $a[0]{certificate} = $object->certificate; # This element is binary. Not sure how to handle inside XML.
        }
        when ('CNAME') {
            $a[0]{cname} = $object->cname;
        }
        when ('DNAME') {
            $a[0]{dname} = $object->dname;
        }
        when ('EID') {
            $a[0]{rdlength} = $object->rdlength;
#            $a[0]{rdata} = $object->rdata; # This element is binary. Not sure how to handle inside XML.
        }
        when ('HINFO') {
            $a[0]{cpu} = $object->cpu;
            $a[0]{os} = $object->os;
        }
        when ('IPSECKEY') {
            $a[0]{algorithm} = $object->algorithm;
            $a[0]{precedence} = $object->precedence;
            $a[0]{gatetype} = $object->gatetype;
            $a[0]{gateway} = $object->gateway;
            $a[0]{pubkey} = $object->pubkey;
            $a[0]{pubbin} = $object->pubbin;
        }
        when ('ISDN') {
            $a[0]{address} = $object->address;
            $a[0]{sa} = $object->sa;
        }
        when ('LOC') {
            $a[0]{version} = $object->version;
            $a[0]{size} = $object->size;
            $a[0]{horiz_pre} = $object->horiz_pre;
            $a[0]{vert_pre} = $object->vert_pre;
            $a[0]{latitude} = $object->latitude;
            $a[0]{longitude} = $object->longitude;
            $a[0]{latlon} = $object->latlon;
            $a[0]{altitude} = $object->altitude;
        }
        when ('MB') {
            $a[0]{madname} = $object->madname;
        }
        when ('MG') {
            $a[0]{mgmname} = $object->mgmname;
        }
        when ('MINFO') {
            $a[0]{rmailbx} = $object->rmailbx;
            $a[0]{emailbx} = $object->emailbx;
        }
        when ('MR') {
            $a[0]{newname} = $object->newname;
        }
        when ('MX') {
            $a[0]{preference} = $object->preference;
            $a[0]{exchange} = $object->exchange;
        }
        when ('NAPTR') {
            $a[0]{order} = $object->order;
            $a[0]{preference} = $object->preference;
            $a[0]{flags} = $object->flags;
            $a[0]{service} = $object->service;
            $a[0]{regexp} = $object->regexp;
            $a[0]{replacement} = $object->replacement;
        }
        when ('NIMLOC') {
            $a[0]{rdlength} = $object->rdlength;
#            $a[0]{rdata} = $object->rdata; # This element is binary. Not sure how to handle inside XML.
        }
        when ('NS') {
            $a[0]{nsdname} = $object->nsdname;
        }
        when ('NSAP') {
            $a[0]{idp} = $object->idp;
            $a[0]{dsp} = $object->dsp;
            $a[0]{afi} = $object->afi;
            $a[0]{idi} = $object->idi;
            $a[0]{dfi} = $object->dfi;
            $a[0]{aa} = $object->aa;
            $a[0]{rsvd} = $object->rsvd;
            $a[0]{rd} = $object->rd;
            $a[0]{area} = $object->area;
            $a[0]{id} = $object->id;
            $a[0]{sel} = $object->sel;
        }
        when ('NULL') {
            $a[0]{rdlength} = $object->rdlength;
#            $a[0]{rdata} = $object->rdata; # This element is binary. Not sure how to handle inside XML.
        }
        when ('PTR') {
            $a[0]{ptrdname} = $object->ptrdname;
        }
        when ('PX') {
            $a[0]{preference} = $object->preference;
            $a[0]{map822} = $object->map822;
            $a[0]{mapx400} = $object->mapx400;
        }
        when ('RP') {
            $a[0]{mbox} = $object->mbox;
            $a[0]{txtdname} = $object->txtdname;
        }
        when ('RT') {
            $a[0]{preference} = $object->preference;
            $a[0]{intermediate} = $object->intermediate;
        }
        when ('SOA') {
            $a[0]{mname} = $object->mname;
            $a[0]{rname} = $object->rname;
            $a[0]{serial} = $object->serial;
            $a[0]{refresh} = $object->refresh;
            $a[0]{serial} = $object->serial;
            $a[0]{expire} = $object->expire;
            $a[0]{minimum} = $object->minimum;
        }
        when ('SRV') {
            $a[0]{priority} = $object->priority;
            $a[0]{weight} = $object->weight;
            $a[0]{port} = $object->port;
            $a[0]{target} = $object->target;
        }
        when ('SSHFP') {
            $a[0]{algorithm} = $object->algorithm;
            $a[0]{fingerprint} = $object->fingerprint;
#            $a[0]{fpbin} = $object->fpbin; # This element is binary. Not sure how to handle inside XML.
            $a[0]{fptype} = $object->fptype;
            $a[0]{babble} = $object->babble;
        }
        when ('TKEY') {
            $a[0]{algorithm} = $object->algorithm;
            $a[0]{inception} = $object->inception;
            $a[0]{expiration} = $object->expiration;
            $a[0]{mode} = $object->mode;
            $a[0]{error} = $object->error;
            $a[0]{other_len} = $object->other_len;
            $a[0]{other_data} = $object->other_data;
        }
        when ('TSIG') {
            $a[0]{algorithm} = $object->algorithm;
            $a[0]{time_signed} = $object->time_signed;
            $a[0]{fudge} = $object->fudge;
            $a[0]{mac_size} = $object->mac_size;
            $a[0]{mac} = $object->mac;
            $a[0]{original_id} = $object->original_id;
            $a[0]{error} = $object->error;
            $a[0]{other_len} = $object->other_len;
            $a[0]{other_data} = $object->other_data;
            $a[0]{sig_data} = $object->sig_data;
        }
        when ('TXT') {
            $a[0]{txtdata} = join('', $object->char_str_list());
        }
        when ('X25') {
            $a[0]{psdn} = $object->psdn;
        }
    }
    
    # Return to sender.
    return @a;
}

1;

__END__

=pod

=head1 NAME

Net::DNS::XML - Transforms a Net::DNS::Packet into well formed XML.

=head1 SYNOPSIS

    #!/usr/bin/perl
    
    use Net::DNS::Resolver;
    use Net::DNS::XML;

    # Create Net::DNS::Packet object.
    my $resolver = Net::DNS::Resolver->new();
    my $answer = $resolver->query('quarg.com', 'A', 'IN');

    # Create Net::DNS::XML object.
    my $xmlout = Net::DNS::XML->new([<options>]);
    my $xml = $xmlout->XMLout($answer [, <options>]);
    
=head1 QUICK START

A script that takes two arguments, hostname and record type:

    my $resolver = Net::DNS::Resolver->new();
    my $answer = $resolver->query($ARGV[0], $ARGV[1]);

    my $xmlout = Net::DNS::XML->new(KeepRoot => 1);
    my $xml = $xmlout->XMLout($answer);

    print $xml;

Would output the following XML (which has been wrapped in this example to fit 
on screen:

  <packet answerfrom="205.234.103.204" answersize="95">
    <header id="26002" aa="0" ad="0" ancount="1" arcount="1" cd="0" nscount="2"
            opcode="QUERY" qdcount="1" qr="1" ra="1" rcode="NOERROR" rd="1" tc="0" />
    <questions>
      <question qclass="IN" qname="quarg.com" qtype="A" />
    </questions>
    <answers>
      <answer name="quarg.com" address="208.113.230.163" class="IN" rdlength="4" 
              ttl="86400" type="A" />
    </answers>
    <authorities>
      <authority name="quarg.com" class="IN" nsdname="ns2.quarg.com" rdlength="6"
                 ttl="72051" type="NS" />
      <authority name="quarg.com" class="IN" nsdname="ns1.quarg.com" rdlength="6"
                 ttl="72051" type="NS" />
    </authorities>
    <additionals>
      <additional name="ns1.quarg.com" address="74.200.85.159" class="IN" 
                  rdlength="4" ttl="86400" type="A" />
    </additionals>
  </packet>


=head1 DESCRIPTION


=head2 Keep in mind


=head1 CAVEATS

While all Net::DNS::RR objects are able to be parsed into XML using this module, 
some types are not I<fully> parsed. This is primarly because they output binary 
data. I haven't figured out (honestly I haven't looked at it at all) how to
represent binary data in xml. Or if it's even possible. It is my hope that all 
record types provided by Net::DNS will ultimately be included.

The fully parsable record types:

* L<Net::DNS::RR::A>
* L<Net::DNS::RR::AAAA>
* L<Net::DNS::RR::AFSDB>
* L<Net::DNS::RR::CNAME>
* L<Net::DNS::RR::DNAME>
* L<Net::DNS::RR::HINFO>
* L<Net::DNS::RR::IPSECKEY>
* L<Net::DNS::RR::ISDN>
* L<Net::DNS::RR::LOC>
* L<Net::DNS::RR::MB>
* L<Net::DNS::RR::MG>
* L<Net::DNS::RR::MINFO>
* L<Net::DNS::RR::MR>
* L<Net::DNS::RR::MX>
* L<Net::DNS::RR::NAPTR>
* L<Net::DNS::RR::NS>
* L<Net::DNS::RR::NSAP>
* L<Net::DNS::RR::PTR>
* L<Net::DNS::RR::PX>
* L<Net::DNS::RR::RP>
* L<Net::DNS::RR::RT>
* L<Net::DNS::RR::SRV>
* L<Net::DNS::RR::SOA>
* L<Net::DNS::RR::TXT>
* L<Net::DNS::RR::TKEY>
* L<Net::DNS::RR::TSIG>
* L<Net::DNS::RR::X25>


The incomplete record types:

* L<Net::DNS::RR::APL>
* L<Net::DNS::RR::CERT>
* L<Net::DNS::RR::EID>
* L<Net::DNS::RR::NIMLOC>
* L<Net::DNS::RR::NULL>
* L<Net::DNS::RR::SSHFP>


=head1 SEE ALSO

L<Net::DNS>, L<XML::Simple>, and our Web site: 
L<http://code.google.com/p/perl-net-dns-xml/>.

=head1 AUTHOR

Michael De Soto, E<lt>desoto@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008-2009 Michael De Soto. All rights reserved.

This program is free software: you can redistribute it and/or modify it under 
the terms of the GNU General Public License as published by the Free Software 
Foundation, either version 3 of the License, or (at your option) any later 
version.

This program is distributed in the hope that it will be useful, but WITHOUT ANY 
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A 
PARTICULAR PURPOSE.  See the GNU General Public License for more details.

You should have received a copy of the GNU General Public License along with 
this program.  If not, see L<http://www.gnu.org/licenses/>.

=cut
